home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / regexp.stk < prev    next >
Encoding:
Text File  |  1996-07-21  |  3.4 KB  |  106 lines
  1. ;;;;
  2. ;;;; r e g e x p . s t k         -- Regular expressions
  3. ;;;;
  4. ;;;;
  5. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6. ;;;; 
  7. ;;;; Permission to use, copy, and/or distribute this software and its
  8. ;;;; documentation for any purpose and without fee is hereby granted, provided
  9. ;;;; that both the above copyright notice and this permission notice appear in
  10. ;;;; all copies and derived works.  Fees for distribution or use of this
  11. ;;;; software or derived works may only be charged with express written
  12. ;;;; permission of the copyright holder.  
  13. ;;;; This software is provided ``as is'' without express or implied warranty.
  14. ;;;;
  15. ;;;;
  16. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  17. ;;;;    Creation date:  9-Nov-1994 13:24
  18. ;;;; Last file update: 21-Jul-1996 18:41
  19. ;;;;
  20. ;;;; Regexp-replace-all bug correction due to Sean Slattery 
  21. ;;;; <jslttery@GS148.SP.CS.CMU.EDU>
  22.  
  23. (if (symbol-bound? '%init-regexp)
  24.     ;; Regexp module is in the core interpreter
  25.     (%init-regexp)
  26.     ;; Try to load regexp module dynamically
  27.     (load (string-append "sregexp." *shared-suffix*)))
  28.  
  29. (define (replace-string string ind1 ind2 new)
  30.   (string-append (substring string 0 ind1)
  31.          new
  32.          (substring string ind2 (string-length string))))
  33.  
  34. (define regexp-replace        #f)
  35. (define regexp-replace-all    #f)
  36.  
  37. (let ()
  38.  
  39.   ;; Utility function
  40.   ;; Given a string  and a set of substitutions, return the substitued string
  41.   (define (replace-submodels string subst match)
  42.     (if (= (length match) 1)
  43.     ;; There is no sub-model
  44.     subst
  45.     ;; There are at least one sub-model to replace
  46.     (let Loop ((subst subst))
  47.       (let ((pos ((string->regexp "\\\\[0-9]") subst)))
  48.         (if pos
  49.         ;; At least one \x in the substitution string
  50.         (let* ((index (+ (caar pos) 1))
  51.                (val   (string->number (substring subst index (+ index 1)))))
  52.           (if (>= val (length match))
  53.               (error "regexp-replace: cannot match \\~A in model" val)
  54.               ;; Build a new subst with the current \x remplaced by 
  55.               ;; its value. Iterate for further \x
  56.               (Loop (replace-string subst 
  57.                         (caar pos)
  58.                         (cadar pos)
  59.                         (apply substring string
  60.                            (list-ref match val))))))
  61.         ;; No \x in substitution string
  62.         subst)))))
  63.  
  64.   ;; If there is a match, call replace-submodels; otherwise return string unmodified
  65.   ;; This function takes an iterator function to allow multiple substitution
  66.   ;; (iterator function = Identity for regexp-replace)
  67.   (set! regexp-replace 
  68.     (lambda (pat str subst)
  69.       (let* ((regexp (cond
  70.               ((regexp? pat) pat)
  71.               ((string? pat) (string->regexp pat))
  72.               (else  (error "regexp-replace: Bad pattern '~1'" pat))))
  73.          (match   (regexp str)))
  74.         (if match
  75.         ;; There was a match
  76.         (replace-string str 
  77.                 (caar match) 
  78.                 (cadar match) 
  79.                 (replace-submodels str subst match))
  80.         ;; No match, return the original string
  81.         str))))
  82.  
  83.  
  84.   (set! regexp-replace-all          
  85.     (lambda (pat str subst)          
  86.       (letrec ((regexp-replace-all-r
  87.             (lambda (regexp str subst)
  88.               (let ((match (regexp str)))
  89.             (if match
  90.                 (string-append (substring str 0 (caar match))
  91.                        (replace-submodels str subst match)
  92.                        (regexp-replace-all-r
  93.                                 regexp 
  94.                             (substring str 
  95.                                    (cadar match) 
  96.                                    (string-length str))
  97.                             subst))
  98.                 str)))))
  99.         (let ((regexp (cond
  100.                ((regexp? pat) pat)
  101.                ((string? pat) (string->regexp pat))
  102.                (else  (error "regexp-replace: Bad pattern '~1'" pat)))))
  103.           (regexp-replace-all-r regexp str subst))))))
  104.  
  105. (provide "regexp")
  106.